home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / smaltalk / manchest.lha / MANCHESTER / V / CategoryBrowser.st next >
Text File  |  1993-07-24  |  64KB  |  1,997 lines
  1. "    NAME        CategoryBrowser 
  2.     AUTHOR        Max Ott (ott%piyopiyo.hatori.t.u-tokyo.ac.jp)
  3.     FUNCTION    categorized class browser
  4.     ST-VERSION    V/286
  5.     PREREQUISITES    
  6.     CONFLICTS
  7.     DISTRIBUTION    world
  8.     VERSION        1
  9.     DATE    26 Mar 90
  10. SUMMARY  Max Ott's Category and
  11. Project Browser; a substantial upgrade to the ST V/286
  12. environment.
  13. "
  14. !
  15. "
  16. From: MUHRTH@tubvm.cs.tu-berlin.de (Thomas Muhr)
  17. Newsgroups: comp.lang.smalltalk
  18. Subject: Repost of Max Ott's CategoryBrowser for ST V
  19. Message-ID: <90218.103757MUHRTH@DB0TUI11.BITNET>
  20. Date: 6 Aug 90 08:37:57 GMT
  21. Organization: Technical University Berlin
  22.  
  23. Because of frequent requests I repost Max Ott's Category and
  24. Project Browser, which is a substantial upgrade to the ST V/286
  25. environment, although there are a few features which are lacking or
  26. do not function properly. Anyway I already don't know how I could have
  27. been working without it. If trouble comes up, you can address the author
  28. whom I will send updates which have emerged during our experience with the
  29. browser.
  30. What follows is the original posting (I do not know if there have been
  31. upgrades in the meantime.
  32. - Have fun,
  33. - Thomas
  34.  
  35. Received: by tub.UUCP; Mon, 26 Mar 90 23:15:59 +0100; AA25036
  36. Received: by tmpmbx.UUCP (5.61++/smail2.5); Mon, 26 Mar 90 23:13:50 +0200;
  37.  AA05263
  38. Received: by netmbx.UUCP (5.61++/smail2.5); Mon, 26 Mar 90 22:52:33 +0200;
  39.  AA00152
  40. From: morus%netmbx.UUCP@tub.BITNET (Thomas Muhr)
  41. Message-Id: <9003262052.AA00152@netmbx.UUCP>
  42. Subject: catbrowser
  43. To: db0tui11.BITNET!!muhrth@tub.UUCP
  44. Date: Mon, 26 Mar 90 22:52:30 MEST
  45. X-Mailer: ELM [version 2.2 PL7]
  46.  
  47.  
  48. *   ProjectClassHBrowser
  49. *   Copyright (c) 1990
  50. *   By Max Ott (ott%piyopiyo.hatori.t.u-tokyo.ac.jp)
  51. *   All rights reserved.
  52. *
  53. *  This program is provided for UNRESTRICTED use provided that this
  54. *  copyright message is preserved on all copies and derivative works.
  55. *  This is provided without any warranty. No author or distributor
  56. *  accepts any responsibility whatsoever to any person or any entity
  57. *  with respect to any loss or damage caused or alleged to be caused
  58. *  directly or indirectly by this program. This includes, but is not
  59. *  limited to, any interruption of service, loss of business, loss of
  60. *  information, loss of anticipated profits, core dumps, abuses of the
  61. *  virtual memory system, or any consequential or incidental damages
  62. *  resulting from the use of this program.
  63. *
  64. ****************************
  65. *
  66. *   Project: categorized class browser
  67. *
  68.  
  69.     (Disk file: 'catInit.cls') fileIn; close.
  70.  
  71. "
  72.  
  73. Smalltalk at: #GlobalCategoryDictionary put: Dictionary new.!
  74.  
  75. ClassReader subclass: #CategoryClassReader
  76.   instanceVariableNames:
  77.     'category '
  78.   classVariableNames: ''
  79.   poolDictionaries: '' !
  80.  
  81. !Behavior methods!
  82.  
  83. addSelector: aSelector category: aCategory
  84.         "add a selector to aCategory. Store this association
  85.          in GlobalCategoryDictionary. As this is also used to
  86.          file in new methods, better make sure that aSelector
  87.          is not stored under a different category.
  88. !!!!!! max."
  89.     | categories |
  90.     categories := self allCategories.
  91.     categories do: [ :cat |
  92.         cat remove: aSelector ifAbsent: [ nil ]
  93.     ].
  94.     ( categories at: aCategory
  95.         ifAbsent: [ categories at: aCategory put: Set new ])
  96.             add: aSelector. !
  97.  
  98. allCategories
  99.         "Return a dictionary with all the categories as keys.
  100.          Each corresponding value contains a set of all
  101.          the methods in this category.
  102.          I used the basicHash as identifier for the class.
  103.          I am not sure but storing self will put an instance
  104.          into the global dictionary. It will then be impossible
  105.          to add new instance variables to a method. This is
  106.          at least the way I think this variable adding business
  107.          works.
  108.          Plain hash does not work as it uses the hash of the name
  109.          which is not exclusive.
  110.          If you change to another form of key, also change
  111.          removeAllCategories. (should have its own method, though)
  112. !!!!!! max"
  113.     | categories |
  114.     categories := GlobalCategoryDictionary at: self basicHash
  115.                         ifAbsent: [ nil ].
  116.     categories isNil
  117.         ifTrue: [
  118.             "put every method in default category"
  119.             categories := Dictionary new.
  120.             self selectors size = 0
  121.                 ifFalse: [  "there is something to put"
  122.                     categories at: #etc put: self selectors
  123.                 ].
  124.             GlobalCategoryDictionary at: self basicHash
  125.                 put: categories.
  126.         ].
  127.     ^categories!
  128.  
  129. category: aSelector
  130.         "returns the category for aSelector. If
  131.          none is found return nil.
  132. !!!!!! max"
  133.     | classDict answer |
  134.     classDict := self allCategories.
  135.     answer := ( classDict select: [ :aSet |
  136.                     aSet includes: aSelector ]) keys.
  137.     answer size = 0 ifTrue: [ ^nil ].
  138.     answer size = 1 ifTrue: [ ^answer asArray at: 1 ].
  139.     self error: aSelector print, ' is stored under 2 different categories.'!
  140.  
  141. categoryFor: aSelector
  142.         "return the category of aSelector.
  143. !!!!!! max"
  144.     self allCategories keysValuesDo: [ :aCategory :aSet |
  145.         ( aSet detect: [ :sample | sample = aSelector ]
  146.                 ifNone: [ nil ])
  147.             isNil
  148.         ifFalse: [ ^aCategory ]
  149.     ].
  150.     self error: 'no category found for <',
  151.         aSelector printString, '>'!
  152.  
  153. changeCategoryFor: aSelector
  154.     from: currentCategory
  155.     to: newCategory
  156.         "change the category of aSelector to newCategory.
  157.          Don't check if everything is around.
  158. !!!!!! max"
  159.     | categories |
  160.     categories := self allCategories.
  161.     ( categories at: currentCategory) remove: aSelector.
  162.     ( categories at: newCategory) add: aSelector.!
  163.  
  164. compile: codeString  category: aCategory
  165.         "Compile the Smalltalk method contained in codeString.
  166.          The class to use for resolving variables is the receiver.
  167.          If there are no errors, add the method to the receiver
  168.          messageDictionary and also store the category. Further
  169.          answer the Association with the
  170.          message selector as the key and the compiled method
  171.          as the value.  If there is an error, answer nil.
  172. !!!! max"
  173.     | answer |
  174.     answer := Compiler
  175.         compile: codeString
  176.         in: self.
  177.     answer notNil
  178.         ifTrue: [
  179.             self
  180.                 addSelector: answer key category: aCategory;
  181.                 addSelector: answer key withMethod: answer value
  182.         ].
  183.     ^answer!
  184.  
  185.  
  186. methodsInCategory: aCategory
  187.         "Answer an instance of ClassReader
  188.          initialized for the receiver.
  189. !!!!!! max"
  190.     ^CategoryClassReader forClass: self category: aCategory asSymbol!
  191.  
  192. methodsOrig
  193.         "Answer an instance of ClassReader
  194.          initialized for the receiver."
  195.     ^ClassReader forClass: self!
  196.  
  197. removeAllCategories
  198.         "remove all categories for this class. Remove it from
  199.          GlobalCategoryDictionary. This will be called
  200.          when class is removed.
  201. !!!!!! max"
  202.     GlobalCategoryDictionary
  203.         removeKey: self basicHash
  204.         ifAbsent: [ nil ]!
  205.  
  206. removeCategory: aSymbol
  207.         "remove a category from this class. Remove it from
  208.          GlobalCategoryDictionary.
  209. !!!!!! max"
  210.     self allCategories removeKey: aSymbol!
  211.  
  212. removeSelector: aSelector category: aCategory
  213.         "remove a selector from aCategory. Remove this association
  214.          in GlobalCategoryDictionary.
  215. !!!!!! max."
  216.     | categories |
  217.     categories := self allCategories.
  218.     ( categories at: aCategory) remove: aSelector.!
  219.  
  220. renameCategoryFrom: oldCategory to: newCategory
  221.         "rename category oldCategory to newCategory. Change it in
  222.          GlobalCategoryDictionary.
  223. !!!!!! max"
  224.     | classDict |
  225.     classDict := self allCategories.
  226.     classDict at: newCategory
  227.               put: ( classDict at: oldCategory).
  228.     classDict removeKey: oldCategory!
  229.  
  230. selectorsForCategory: aCategory
  231.         "Answer a Set of symbols of the names
  232.          of the methods defined by the receiver
  233.          which are in category aCategory.
  234. !!!!!! max"
  235.     ^self allCategories at: aCategory! !
  236.  
  237.  
  238. ClassReader subclass: #CategoryClassReader
  239.   instanceVariableNames:
  240.     'category '
  241.   classVariableNames: ''
  242.   poolDictionaries: '' !
  243.  
  244. !CategoryClassReader methods!
  245.  
  246. fileInFrom: aStream
  247.         "Read chunks from aStream until an empty chunk
  248.          (a single '!!') is found.  Compile each chunk
  249.          as a method for the class described by the
  250.          receiver.  Log the source code of the method
  251.          to the change log."
  252.     | aString result stream |
  253.     stream := Sources at: 2.
  254.     stream setToEnd.
  255.     self instanceHeaderOn: stream  category: category.
  256.     [(aString := aStream nextChunk zapCrs) isEmpty]
  257.         whileFalse:[
  258.             result := class compile: aString category: category.
  259.             result notNil
  260.                 ifTrue: [result value sourceString: aString]].
  261.     stream
  262.         nextChunkPut: '';
  263.         flush! !
  264.  
  265. !CategoryClassReader class methods!
  266.  
  267. forClass: aClass category: aCategory
  268.         "Answer an instance of the
  269.          receiver for aClass."
  270.     ^self new
  271.         setClass: aClass;
  272.         setCategory: aCategory.! !
  273.  
  274.  
  275. !CategoryClassReader methods!
  276.  
  277. fileInFrom: aStream
  278.         "Read chunks from aStream until an empty chunk
  279.          (a single '!!') is found.  Compile each chunk
  280.          as a method for the class described by the
  281.          receiver.  Log the source code of the method
  282.          to the change log."
  283.     | aString result stream |
  284.     stream := Sources at: 2.
  285.     stream setToEnd.
  286.     self instanceHeaderOn: stream  category: category.
  287.     [(aString := aStream nextChunk zapCrs) isEmpty]
  288.         whileFalse:[
  289.             result := class compile: aString category: category.
  290.             result notNil
  291.                 ifTrue: [result value sourceString: aString]].
  292.     stream
  293.         nextChunkPut: '';
  294.         flush!
  295.  
  296. fileOutOnWithCategories: aStream
  297.         "File out all the methods for the class described
  298.          by the receiver to aStream, in chunk format.
  299.          Also add category names.
  300. !!!!!! don't forget to add Dictionary's keysValuesDo: "
  301.     class allCategories keysValuesDo: [ :category :selectors |
  302.         aStream cr.
  303.         self instanceHeaderOn: aStream category: category.
  304.         selectors asSortedCollection do: [ :selector |
  305.             aStream
  306.                 cr;
  307.                 nextChunkPut: (class sourceCodeAt: selector)
  308.         ].
  309.         aStream nextChunkPut: ''; cr
  310.     ].!
  311.  
  312. fileOutOnWithCategories: aStream  selection: aSet
  313.         "File out all the methods mentioned in aSet
  314.          for the class described
  315.          by the receiver to aStream, in chunk format.
  316.          Also add category names.
  317. !!!!!! don't forget to add Dictionary's keysValuesDo: "
  318.     ( self sortIntoCategories: aSet)
  319.         keysValuesDo: [ :category :selectors |
  320.             aStream cr.
  321.             self instanceHeaderOn: aStream category: category.
  322.             selectors asSortedCollection do: [ :selector |
  323.                 aStream
  324.                     cr;
  325.                     nextChunkPut: (class sourceCodeAt: selector)
  326.             ].
  327.         aStream nextChunkPut: ''; cr
  328.     ].!
  329.  
  330. instanceHeaderOn: aStream  category: aCategory
  331.         "Private - Write a header to aStream which identifies
  332.          the class described by the receiver.  The header
  333.          precedes the source code for the methods.
  334.          Add category too."
  335.     aStream
  336.         cr;
  337.         nextPut: $!!;
  338.         nextPutAll: class name;
  339.         space;
  340.         nextPutAll: 'methodsInCategory: ';
  341.         nextPutAll: aCategory asString printString;
  342.         nextPut: $!!!
  343.  
  344. sortIntoCategories: aSet
  345.         "private - put all the methods in aSet into
  346.          a dictionary where the key is the category
  347.          and the value is a set containing all the methods
  348.          belonging to the same category."
  349.     | dictionary category |
  350.     dictionary := Dictionary new.
  351.     aSet do: [ :aSelector |
  352.         category := class categoryFor: aSelector.
  353.         dictionary at: category
  354.             ifAbsent: [ dictionary at: category put: Set new ].
  355.         ( dictionary at: category) add: aSelector.
  356.     ].
  357.     ^dictionary!
  358.  
  359. setCategory: aCategory
  360.         "Private - Set the category of the next read methods."
  361.     category := aCategory.
  362.     ^self! !
  363.  
  364. !Behavior methods !
  365.  
  366. methods
  367.         "Answer an instance of ClassReader
  368.          initialized for the receiver.
  369.          This is an old script with no category,
  370.          so we better put it in one.
  371. !!!!!! max"
  372.     ^CategoryClassReader forClass: self category: #etc!
  373.  
  374. checkCategories
  375.         "Just to be sure. Check stored categories for double entries
  376.          or selectors without categories.
  377.          In case of a double entry, keep one and throw away the rest.
  378.          Very simple. Too simple? Should not happen anyway.
  379.          In case of no category, create xERRORx category and throw
  380.          it in there. In this case update the category pane.
  381.          Return set containing all the lost children."
  382.     | set errorSet |
  383.     set := Set new.
  384.     self allCategories keysValuesDo: [ :cat :selectors |
  385.         selectors do: [ :method |
  386.             (set includes: method)
  387.                 ifTrue: [ "double entry; remove this one"
  388.                     selectors remove: method.
  389.                     Terminal bell
  390.                 ]
  391.                 ifFalse: [ "first time; store it"
  392.                     set add: method
  393.                 ]
  394.         ]
  395.     ].
  396.     errorSet := Set new.
  397.     self selectors do: [ :method |
  398.         (set includes: method)
  399.             ifFalse: [ "this method has no category"
  400.                 errorSet add: method
  401.             ]
  402.     ].
  403.     ^errorSet!
  404.  
  405. comment
  406.         "return comment
  407. !!!!!! max"
  408.     ^comment!
  409.  
  410. comment: anObject
  411.         "store anObject as comment
  412. !!!!!! max"
  413.     ^comment := anObject!
  414.  
  415. methodsOrig
  416.         "Answer an instance of ClassReader
  417.          initialized for the receiver."
  418.     ^ClassReader forClass: self! !
  419.  
  420. !Dictionary methods !
  421.  
  422. keysValuesDo: aBlock
  423.         "Answer the receiver.  For each key
  424.          in the receiver, evaluate aBlock with
  425.          the key and the value as the arguments."
  426.     self associationsDo: [ :anAssociation |
  427.         aBlock value: anAssociation key value: anAssociation value]! !
  428.  
  429. !Pane methods !
  430.  
  431. popUp: aMenu at: aPoint
  432.         "Display aMenu at aPoint.  If the user
  433.          choice is nil, do nothing.  If the model
  434.          can respond to the choice, let it perform
  435.          the choice. Else, let the dispatcher perform it.
  436. !!max    return immediatly if aMenu is nil. ( model
  437.             doesn't want it.)
  438.         deactivate pane before calling menu."
  439.     | aSymbol |
  440.     aMenu isNil
  441.         ifTrue: [ ^self ].
  442.     self hasZoomedPane  "deactivating zoomed pane causes dezooming"
  443.         ifFalse: [ self deactivatePane ].
  444.     aSymbol := aMenu popUpAt: aPoint.
  445.     self hasZoomedPane
  446.         ifFalse: [ self activatePane ].
  447.     aSymbol isNil
  448.         ifFalse: [
  449.             (model respondsTo: aSymbol)
  450.                 ifTrue: [model perform: aSymbol]
  451.                 ifFalse:[dispatcher perform: aSymbol]] ! !
  452.  
  453. "
  454. *   ProjectClassHBrowser
  455. *   Copyright (c) 1990
  456. *   By Max Ott (ott%piyopiyo.hatori.t.u-tokyo.ac.jp)
  457. *   All rights reserved.
  458. *
  459. *  This program is provided for UNRESTRICTED use provided that this
  460. *  copyright message is preserved on all copies and derivative works.
  461. *  This is provided without any warranty. No author or distributor
  462. *  accepts any responsibility whatsoever to any person or any entity
  463. *  with respect to any loss or damage caused or alleged to be caused
  464. *  directly or indirectly by this program. This includes, but is not
  465. *  limited to, any interruption of service, loss of business, loss of
  466. *  information, loss of anticipated profits, core dumps, abuses of the
  467. *  virtual memory system, or any consequential or incidental damages
  468. *  resulting from the use of this program.
  469. *
  470. ****************************
  471. *   Mar 20, 1990  22:08:13
  472. *
  473. *   Project: project_browser
  474. *
  475.  
  476.     (Disk file: 'catInit.cls') fileIn; close.
  477.     (Disk file: 'prjct_br.cls') fileIn; close.
  478.  
  479.     To test it, execute:
  480.  
  481.         ProjectClassHBrowser new  openOn: (Array with: Object)
  482.  
  483.     To install it as system menu default, execute:
  484.  
  485.         ProjectClassHBrowser install
  486. "!
  487.  
  488. !Behavior methodsInCategory: 'comment'!
  489.  
  490. commentFor: aVariable
  491.         "return comment for aVariable
  492. !!!!!! max"
  493.     comment isNil
  494.         ifTrue: [
  495.             ^'not documented'
  496.         ].
  497.     ^comment at: aVariable ifAbsent: [ 'not documented' ]!
  498.  
  499. commentFor: aVariable put: aString
  500.         "store comment aString for aVariable
  501. !!!!!! max"
  502.     comment isNil
  503.         ifTrue: [
  504.             comment := Dictionary new
  505.         ].
  506.     ^comment at: aVariable put: aString! !
  507. ClassHierarchyBrowser subclass: #CategorizedClassBrowser
  508.   instanceVariableNames:
  509.     'selectedClassString selectedCategory currentCategory displayedMethod
  510.  history '
  511.   classVariableNames: ''
  512.   poolDictionaries: ''!
  513.  
  514. CategorizedClassBrowser class comment:
  515. 'This browser adds the ability to group methods
  516. of a class into categories, like the big brother
  517. does. Compared with the ClassHierarchyBrowser,
  518. it adds one window in the center of the top
  519. half of the pane. This pane shows the categories
  520. defined for the currently selected class. Another
  521. small pane above the left half of the text pane
  522. shows the category of the currently selected method.
  523. The menu in this pane shows all the defined
  524. categories and can be used to change the
  525. category for the currently displayed method.
  526. '.
  527.  
  528. CategorizedClassBrowser commentFor: 'selectedCategory' put:
  529. 'Contains the most recently selected category,
  530. or nil if no one is selcted.
  531. '.
  532.  
  533. CategorizedClassBrowser commentFor: 'selectedClassString' put:
  534. 'Stores string of selected class as it appears
  535. in the class pane. This is necessary for the
  536. history to select a class in the class pane
  537. because the class names are indented.
  538. '.
  539.  
  540. CategorizedClassBrowser commentFor: 'currentCategory' put:
  541. 'Contains the category of the currently displayed
  542. method in the text pane.
  543. '.
  544.  
  545. CategorizedClassBrowser commentFor: 'displayedMethod' put:
  546. 'Contains the method currently displayed in
  547. the text pane.
  548.  
  549. '.
  550.  
  551. CategorizedClassBrowser commentFor: 'history' put:
  552. 'Contains the history of the last few selected
  553. methods. This way it is a bit easier to jump
  554. between methods in different classes.
  555.  
  556. The length of the history list is set in
  557. <history length>. See category history for more
  558. details on the structure of each data item
  559. in this list.
  560. '.
  561.  
  562.  !
  563. CategorizedClassBrowser subclass: #ProjectClassHBrowser
  564.   instanceVariableNames:
  565.     'projectName changeDirectory changeLog '
  566.   classVariableNames:
  567.     'Projects '
  568.   poolDictionaries: ''!
  569.  
  570. ProjectClassHBrowser class comment:
  571. 'This class browser keeps track of all the classes
  572. and methods created while working on a particular
  573. project. Selecting the <file out> option in the
  574. top pane menu files out all the changed and newly
  575. created master pieces. This file also includes
  576. a header for conviniently restoring the contents
  577. within an other image. I also use it as a kind
  578. of documentation.
  579. '.
  580.  
  581. ProjectClassHBrowser commentFor: 'changeDirectory' put:
  582. 'All projects are stored in the class variable
  583. Projects. Projects is a dictionary with the
  584. project names as keys and a separate dictionary
  585. for each project as values. changeDirectory
  586. contains a pointer to this individual dictionary.
  587. '.
  588.  
  589. ProjectClassHBrowser commentFor: 'Projects' put:
  590. 'Contains a list of all the currently known
  591. projects in this image. By starting up a new
  592. ProjectBrowser, the user will get a menu with
  593. all those names.
  594. '.
  595.  
  596. ProjectClassHBrowser commentFor: 'changeLog' put:
  597. 'Not used yet. Had this idea of keeping a seperate
  598. change log file for each project. Not sure if this
  599. would be useful for anything.
  600. '.
  601.  
  602. ProjectClassHBrowser commentFor: 'projectName' put:
  603. 'Contains the name of the project we are currently
  604. working on. The same name is also displayed in
  605. the window header.
  606. '.
  607.  
  608.  !
  609. Object subclass: #ClassDocBrowser
  610.   instanceVariableNames:
  611.     'class variable '
  612.   classVariableNames: ''
  613.   poolDictionaries: ''!
  614.  
  615. ClassDocBrowser class comment:
  616. 'A ClassDocBrowser supports reading and saving
  617. verbal explanation of the purpose of a class
  618. (stored in the pseudo variable CLASS) and all
  619. the instance, class, and pool variables.
  620. '.
  621.  
  622. ClassDocBrowser commentFor: 'class' put:
  623. 'Contains the class we are displaying the
  624. documentation for.
  625.  
  626. The docu text is stored in the instance variable
  627. <comment> in class Behavior.
  628. '.
  629.  
  630. ClassDocBrowser commentFor: 'variable' put:
  631. 'Contains the currently selected variable.
  632. '.
  633.  
  634.  !
  635.  
  636. !CategorizedClassBrowser class methodsInCategory: 'bugs&info'!
  637.  
  638. author
  639.         "if you have any complaints, suggestions, or
  640.          whatever send me a message under"
  641.     ^'ott@piyopiyo.hatori.t.u-tokyo.ac.jp'!
  642.  
  643. bugs
  644.         "return string telling you about the known bugs"
  645.     ^'
  646. CategorizedClassBrowser:
  647. ========================
  648.  
  649. 1) If you edit the name of a method and you change
  650.     the category, you''ll change the category of the
  651.     originally displayed method. This could be prevented
  652.     by asking the text pane if it is modified before
  653.     changing the category. However, we don''t keep
  654.     the name of the text pane around. Would need a new
  655.     instance variable and a check to
  656.         <textPane dispatcher modified>'! !
  657.  
  658.  
  659. !CategorizedClassBrowser methodsInCategory: 'classes'!
  660.  
  661. addSubClass
  662.         "Private - Add a subclass to the selected
  663.          class.  If a class is selected, prompt the
  664.          user for a new class name and add it as a
  665.          subclass to the selected class."
  666.     | newName subclassType answer |
  667.     selectedClass isNil
  668.         ifTrue: [^self].
  669.     newName := Prompter
  670.         prompt: selectedClass name , ' subclass?'
  671.         default: ''.
  672.     (newName isNil or: [newName isEmpty])
  673.         ifTrue: [^nil].
  674.     (newName at: 1) isUpperCase
  675.         ifFalse: [
  676.             newName at: 1
  677.             put: (newName at: 1) asUpperCase].
  678.     newName := newName asSymbol.
  679.     (Smalltalk includesKey: newName)
  680.         ifTrue: [^self error: newName, ' already exists'].
  681.     subclassType := (Menu
  682.         labels: 'subclass\variableSubclass\variableByteSubclass' withCrs
  683.         lines: Array new
  684.         selectors: #(pointer indexed byte))
  685.             popUpAt: Cursor offset.
  686.     (subclassType == #pointer and: [selectedClass isVariable])
  687.         ifTrue: [
  688.             (Prompter
  689.                 prompt: 'Indexed pointer subclass assumed. Confirm (y/n)'
  690.                 default: (String with: $y)) asLowerCase
  691.                     = (String with: $y)
  692.             ifFalse: [^self]].
  693.     subclassType == #pointer
  694.         ifTrue: [
  695.             ((selectedClass subclass: newName
  696.                 instanceVariableNames: ''
  697.                 classVariableNames: ''
  698.                 poolDictionaries: '')
  699.                     isKindOf: Class)
  700.                         ifFalse: [^self]].
  701.     subclassType == #indexed
  702.         ifTrue: [
  703.             ((selectedClass variableSubclass: newName
  704.                 instanceVariableNames: ''
  705.                 classVariableNames: ''
  706.                 poolDictionaries: '')
  707.                     isKindOf: Class)
  708.                         ifFalse: [^self]].
  709.     subclassType == #byte
  710.         ifTrue: [
  711.             ((selectedClass variableByteSubclass: newName
  712.                 classVariableNames: ''
  713.                 poolDictionaries: '')
  714.                     isKindOf: Class)
  715.                         ifFalse: [^self]].
  716.     subclassType isNil ifTrue: [^self].
  717.     selectedClass := Smalltalk at: newName asSymbol.
  718.     CursorManager execute change.
  719.     selectedMethod := nil.
  720.     selectedCategory := nil.
  721.     methodSelectedLast := false.
  722.     self update: originalClasses.
  723.     self
  724.         changed: #hierarchy
  725.         with: #restoreSelected:
  726.         with: ((String new:
  727.             (Smalltalk at: newName asSymbol)
  728.                 allSuperclasses size)
  729.                     atAllPut: $ ), newName.
  730.     self
  731.         changed: #categories;
  732.         changed: #selectors;
  733.         changed: #text!
  734.  
  735. fileOut
  736.         "Private - Write the source for the selected class
  737.          in chunk file format to a file named with the class
  738.          name reduced to 8 characters, extension 'cls'."
  739.     | aFileStream |
  740.     selectedClass isNil
  741.         ifTrue: [^self].
  742.     CursorManager execute change.
  743.     aFileStream := Disk newFile:
  744.         (File
  745.             fileName: selectedClass name
  746.             extension: (String with: $c with: $l with: $s)).
  747.     aFileStream lineDelimiter: 10 asCharacter.
  748.     selectedClass fileOutOn: aFileStream.
  749.     selectedClass fileOutDocOn: aFileStream.
  750.     aFileStream nextChunkPut: String new.
  751.     (CategoryClassReader forClass: selectedClass class)
  752.         fileOutOnWithCategories: aFileStream.
  753.     (CategoryClassReader forClass: selectedClass)
  754.         fileOutOnWithCategories: aFileStream.
  755.     aFileStream close.
  756.     CursorManager normal change!
  757.  
  758. getClass: aString
  759.         "private - return the class object described by
  760.          aString. If this class is not found, complain
  761.          and return nil."
  762.     | string aClass |
  763.     string := aString.
  764.     string last == $.
  765.         ifTrue: [
  766.             string := string copyFrom: 1
  767.                 to: string size - 3].
  768.     aClass := Smalltalk
  769.                 at: string trimBlanks asSymbol
  770.         ifAbsent: [
  771.             Menu message: 'non-existent class'.
  772.             self update.
  773.             ^nil].
  774.     ^aClass!
  775.  
  776. hideShow
  777.         "Private - Change the hide/show
  778.          status of the selected class."
  779.     selectedClass isNil
  780.         ifTrue: [^nil].
  781.     CursorManager execute change.
  782.     (hiddenClasses includes: selectedClass)
  783.         ifTrue: [
  784.             hiddenClasses remove: selectedClass]
  785.         ifFalse: [
  786.             selectedClass subclasses isEmpty
  787.                 ifFalse: [
  788.                     hiddenClasses add: selectedClass]].
  789.     methodSelectedLast := false.
  790.     self initSelectedCategory.
  791.     selectedMethod := nil.
  792.     self
  793.         update: originalClasses;
  794.         changed: #hierarchy
  795.             with: #restoreSelected;
  796.         changed: #categories
  797.             with: #restoreSelected:
  798.             with: selectedCategory;
  799.         changed: #selectors;
  800.         changed: #text.!
  801.  
  802. hierarchy: aString
  803.         "Private - Display the selectors for the
  804.          selected class in the selector list pane."
  805.     | string aClass |
  806.     string := aString.
  807.     ( aClass := self getClass: aString) isNil
  808.         ifTrue: [ ^self ].
  809.     selectedClassString := aString.
  810.     selectedClass == aClass
  811.         ifTrue: [^self hideShow].
  812.     methodSelectedLast := false.
  813.     selectedMethod := nil.
  814.     selectedClass := aClass.
  815.     "if there is only one category; select it."
  816.     self initSelectedCategory.
  817.     selectedCategory isNil
  818.         ifTrue: [ "start with the first item"
  819.             self changed: #categories
  820.         ]
  821.         ifFalse: [
  822.             self changed: #categories
  823.                     with: #restoreSelected:
  824.                     with: selectedCategory
  825.         ].
  826.     self
  827.         changed: #selectors;
  828.         changed: #text.
  829.     self checkCategories.!
  830.  
  831. removeSubClass
  832.         "Private - Delete the selected class."
  833.     | newName subclassType answer |
  834.     selectedClass isNil
  835.         ifTrue: [^nil].
  836.     newName := Prompter
  837.         prompt: selectedClass name , ' to be deleted? (Y/N)'
  838.         default: 'N'.
  839.     newName isNil ifTrue: [^nil].
  840.     newName asUpperCase = 'Y'
  841.         ifFalse: [^nil].
  842.     selectedClass removeFromSystem.
  843.     selectedClass removeAllCategories.
  844.     CursorManager execute change.
  845.     selectedMethod := nil.
  846.     selectedCategory := nil.
  847.     methodSelectedLast := false.
  848.     self update: originalClasses.
  849.     self changed: #hierarchy
  850.         with: #restore.
  851.     selectedClass := nil.
  852.     self
  853.         changed: #categories;
  854.         changed: #selectors;
  855.         changed: #text!
  856.  
  857. selectedClass
  858.         "private - return the right receiver,
  859.          either class or metaclass."
  860.     ^instanceSelectedLast
  861.         ifTrue: [ selectedClass ]
  862.         ifFalse: [ selectedClass class ]! !
  863.  
  864.  
  865. !CategorizedClassBrowser methodsInCategory: 'initialize'!
  866.  
  867. initWindowSize
  868.         "Private - Answer the initial
  869.          window extent."
  870.     ^Display width * 3 // 4 @
  871.         (Display height * 5 // 6)!
  872.  
  873. openOn: aCollection
  874.         "Create a class hierarchy browser window giving access
  875.          to the classes in aCollection and their subclasses."
  876.     | aTopPane listLineHeight ratio |
  877.     hiddenClasses := Set new.
  878.     history := OrderedCollection new: self historyLength.
  879.     (aCollection includes: Object)
  880.         ifTrue: [
  881.             aCollection do: [ :class |
  882.                 class subclasses do: [:each |
  883.                     each subclasses isEmpty
  884.                         ifFalse: [
  885.                             hiddenClasses add: each]]]]
  886.         ifFalse: [
  887.             aCollection do: [ :class |
  888.                 class subclasses isEmpty
  889.                     ifFalse: [
  890.                         hiddenClasses add: class]]].
  891.     ratio := 2 / 5.
  892.     self update: aCollection.
  893.     listLineHeight := ListFont height + 4.
  894.     instanceSelectedLast := true.
  895.     methodSelectedLast := false.
  896.     aTopPane := TopPane new
  897.         model: self;
  898.         label: self label;
  899.         menu: #topMenu;
  900.         minimumSize: 20 * SysFontWidth
  901.              @ (10 * SysFontHeight);
  902.         rightIcons: #(resize collapse zoom);
  903.         foreColor: 0;
  904.         backColor: 15;
  905.         yourself.
  906.     aTopPane addSubpane:
  907.         (ListPane new
  908.             model: self;
  909.             name: #hierarchy;
  910.             change: #hierarchy:;
  911.             menu: #menu;
  912.             framingBlock: [:box|
  913.                 box origin  extent:
  914.                 (box width * 3 // 9 ) @
  915.                     ((box height * ratio) truncated -
  916.                       listLineHeight)]).
  917.     aTopPane addSubpane:
  918.         ( ListPane new
  919.             model: self;
  920.             name: #categories;
  921.             change: #category:;
  922.             menu: #categoryMenu;
  923.             framingBlock: [:box|
  924.                 box origin + (box width * 3 // 9 @ 0) extent:
  925.                 (box width * 2 // 9 ) @
  926.                     ((box height * ratio) truncated -
  927.                       listLineHeight)];
  928.             yourself).
  929.     aTopPane addSubpane:
  930.         (ListPane new
  931.             model: self;
  932.             name: #selectors;
  933.             change: #selector:;
  934.             menu: #selectorMenu;
  935.             framingBlock: [:box|
  936.                 box origin + ( box width * 5//9 @ 0) extent:
  937.                 (box width * 4 + 8 // 9) @
  938.                     ((box height * ratio) truncated -
  939.                       listLineHeight)]).
  940.     aTopPane addSubpane:
  941.         (ListPane new
  942.             model: self;
  943.             name: #instances;
  944.             change: #instance:;
  945.             selection: 1;
  946.             framingBlock: [:box|
  947.                 box origin+
  948.                     (box width//2 @
  949.                         ((box height * ratio) truncated -
  950.                         (listLineHeight)))
  951.                     extent: box width//4 @
  952.                         (listLineHeight)]).
  953.     aTopPane addSubpane:
  954.         (ListPane new
  955.             model: self;
  956.             name: #classes;
  957.             change: #class:;
  958.             framingBlock: [:box|
  959.                 box origin+
  960.                     (box width//2+(box width//4) @
  961.                         ((box height * ratio) truncated -
  962.                         (listLineHeight)))
  963.                 extent:
  964.                     (box width - (box width//2) -
  965.                         (box width//4)) @
  966.                         (listLineHeight)]).
  967.     aTopPane addSubpane:
  968.         (ListPane new
  969.             model: self;
  970.             name: #editedCategory;
  971.             change: #suppressChange:;
  972.             menu: #changeCategory;
  973.             framingBlock: [:box|
  974.                 box origin+
  975.                     (0 @
  976.                         ((box height * ratio) truncated -
  977.                         (listLineHeight)))
  978.                     extent: box width//2 @
  979.                         (listLineHeight)]).
  980.     aTopPane addSubpane:
  981.         ( TextPane new
  982.             model: self;
  983.             name: #text;
  984.             menu: #textMenu;
  985.             change: #accept:from:;
  986.             framingRatio: (0 @ (ratio)
  987.                         corner: 1 @ 1);
  988.             yourself).
  989.     aTopPane dispatcher open scheduleWindow! !
  990.  
  991.  
  992. !CategorizedClassBrowser methodsInCategory: 'test'!
  993.  
  994. xTestx
  995.     self inspect! !
  996.  
  997.  
  998. !CategorizedClassBrowser methodsInCategory: 'text'!
  999.  
  1000. accept: aString from: aDispatcher
  1001.         "Private - Accept aString as an updated method
  1002.          or class specification and compile it.  Notify
  1003.          aDispatcher if the compiler detects errors."
  1004.     | result aClass |
  1005.     methodSelectedLast
  1006.         ifFalse: [
  1007.             ^self acceptClass: aString from: aDispatcher].
  1008.     aClass := instanceSelectedLast
  1009.         ifTrue: [selectedClass]
  1010.         ifFalse: [selectedClass class].
  1011.     result := self compile: aString
  1012.         notifying: aDispatcher
  1013.         in: aClass.
  1014.     result isNil
  1015.         ifTrue: [^false]
  1016.         ifFalse: [
  1017.             Smalltalk
  1018.                 logSource: aString
  1019.                 forSelector: result key
  1020.                 inClass: aClass.
  1021.             self successfulCompiledMethod: result key.
  1022.             result key == selectedMethod
  1023.                 ifFalse: [
  1024.                     selectedMethod := result key.
  1025.                     displayedMethod := result key.
  1026.                     self selectedClass
  1027.                         addSelector: result key
  1028.                         category: currentCategory.
  1029.                     selectedCategory := currentCategory.
  1030.                     self addCurrentToHistory.
  1031.                     self
  1032.                         changed: #categories
  1033.                             with: #restoreSelected:
  1034.                             with: selectedCategory;
  1035.                         changed: #selectors
  1036.                             with: #restoreSelected:
  1037.                             with: selectedMethod.
  1038.                 ].
  1039.             ^true]!
  1040.  
  1041. compile: aString
  1042.     notifying: aDispatcher
  1043.     in: aClass
  1044.         "Private - Accept aString as an updated
  1045.          method and compile it.  Notify aDispatcher
  1046.          if the compiler detects errors."
  1047.     | answer oldCursor class category confirm |
  1048.     oldCursor := Cursor.
  1049.     CursorManager execute change.
  1050.     class := self selectedClass.
  1051.     answer := Compiler
  1052.         compile: aString
  1053.         in: class
  1054.         notifying: aDispatcher
  1055.         ifFail: [ oldCursor change. ^nil].
  1056.     oldCursor change.
  1057.     category := class category: answer key.
  1058.     ( category isNil or: [ category = currentCategory ])
  1059.         ifFalse: [
  1060.             confirm := Prompter
  1061.                 prompt: answer key , ' also in <', category,
  1062.                     '>. overwrite? (Y/N)'
  1063.                 default: 'N'.
  1064.             confirm isNil ifTrue: [^nil].
  1065.             confirm asUpperCase = 'Y'
  1066.                 ifFalse: [^nil].
  1067.             class changeCategoryFor: answer key
  1068.                 from: category
  1069.                 to: currentCategory
  1070.         ].
  1071.     class addSelector: answer key withMethod: answer value.
  1072.     ^ answer!
  1073.  
  1074. straightTextMenu
  1075.         "private - ask text pane to pop up normal text menu."
  1076.     self changed: #text
  1077.             with: #popUp:
  1078.             with: TextEditor menu!
  1079.  
  1080. successfulCompiledMethod: aMethod
  1081.         "private - aMethod has been sucessfully compiled.
  1082.          Isn't that great. Have a beer."!
  1083.  
  1084. text
  1085.         "Private - Answer the source text for
  1086.          the selected method or class definition
  1087.          for the selected class."
  1088.     selectedClass isNil
  1089.         ifTrue: [^String new].
  1090.     currentCategory :=
  1091.         methodSelectedLast
  1092.             ifTrue: [ selectedCategory ]
  1093.             ifFalse: [ nil].
  1094.     self changed: #editedCategory.
  1095.     ^super text.!
  1096.  
  1097. textMenu
  1098.         "private - if text pane contains method, return
  1099.          standard menu. If it shows class description, get
  1100.          doc menu."
  1101.     methodSelectedLast
  1102.         ifTrue: [ ^TextEditor menu ]
  1103.         ifFalse: [ ^self docMenu ]! !
  1104.  
  1105.  
  1106. !CategorizedClassBrowser methodsInCategory: 'history'!
  1107.  
  1108. addCurrentToHistory
  1109.         "private - add current selection to the end of the
  1110.          history queue. If the queue is full, dump the
  1111.          first item."
  1112.     selectedMethod isNil ifTrue: [ ^nil ].
  1113.     ( history size = self historyLength)
  1114.         ifTrue: [ history removeFirst ].
  1115.     history addLast:
  1116.         (( Array new: 4)
  1117.             at: 1 put: selectedClassString;
  1118.             at: 2 put: selectedCategory;
  1119.             at: 3 put: selectedMethod;
  1120.             at: 4 put: instanceSelectedLast;
  1121.             yourself)!
  1122.  
  1123. gotoClass: aClassString
  1124.     category: aCategory
  1125.     method: aMethod
  1126.     classInstance: aBoolean
  1127.         "private - display text for aMethod in class
  1128.          aClass and category aCategory. But before
  1129.          we change, check if class / instance was
  1130.          not changed."
  1131. "self error: 'goto'. "
  1132.     aBoolean == instanceSelectedLast
  1133.         ifFalse: [ self changeClassInstance: aBoolean ].
  1134.     selectedClass := self getClass: aClassString.
  1135.     selectedClassString := aClassString.
  1136.     selectedCategory := aCategory.
  1137.     selectedMethod := aMethod.
  1138.     displayedMethod := aMethod.
  1139.     methodSelectedLast := true.
  1140.     self addCurrentToHistory.
  1141.     self
  1142.         changed: #text;
  1143.         changed: #hierarchy
  1144.             with: #restoreSelected:
  1145.             with: aClassString;
  1146.         changed: #categories
  1147.             with: #restoreSelected:
  1148.             with: selectedCategory asSymbol;
  1149.         changed: #selectors
  1150.             with: #restoreSelected:
  1151.             with: selectedMethod.!
  1152.  
  1153. historyLength
  1154.         "private - answer the length of the history queue."
  1155.     ^10!
  1156.  
  1157. showHistory
  1158.         "private - pop up a menu with the last n selected
  1159.          methods."
  1160.     | labels selector index selected size |
  1161.     size := history size.
  1162.     labels := OrderedCollection new: size.
  1163.     history do: [ :anArray |
  1164.         ( selector := anArray at: 3) isNil
  1165.             ifFalse: [ labels addLast: selector asString ]
  1166.     ].
  1167.     selectedMethod isNil    "don't display current selected"
  1168.         ifFalse: [ labels removeLast ].
  1169.     index := ( Menu
  1170.                     labelArray: labels
  1171.                     lines: Array new
  1172.                     selectors: ( 1 to: labels size))
  1173.                 popUpAt: Cursor offset.
  1174.     index isNil ifTrue: [ ^nil ].
  1175.     selected := history asArray at: index.
  1176.     self gotoClass: ( selected at: 1)
  1177.          category: ( selected at: 2)
  1178.          method: ( selected at: 3)
  1179.          classInstance: ( selected at: 4)! !
  1180.  
  1181.  
  1182. !CategorizedClassBrowser methodsInCategory: 'category'!
  1183.  
  1184. addCategory
  1185.         "Private - Add a new category."
  1186.     | newCategory |
  1187.     selectedClass isNil
  1188.         ifTrue: [^self].
  1189.     newCategory := Prompter
  1190.         prompt: selectedClass name , ' new category?'
  1191.         default: ''.
  1192.     newCategory isEmpty
  1193.         ifTrue: [ ^self ].
  1194.     self selectedClass
  1195.             addCategory: newCategory asSymbol.
  1196.     selectedCategory := newCategory asSymbol.
  1197.     self
  1198.         changed: #categories
  1199.             with: #restoreSelected:
  1200.             with: selectedCategory asSymbol;
  1201.         changed: #selectors!
  1202.  
  1203. categories
  1204.         "Private - Answer a sorted list of categories
  1205.          for the selected class."
  1206.     | selectors categories |
  1207.     selectedClass isNil
  1208.         ifTrue: [^Array new].
  1209.     ^self selectedClass allCategories keys asSortedCollection!
  1210.  
  1211. category: aSymbol
  1212.         "Private - Display the methods for this new
  1213.          category."
  1214.     selectedCategory := aSymbol asSymbol.
  1215.     selectedMethod := nil.
  1216.     "methodSelectedLast := false."
  1217.     self changed: #selectors!
  1218.  
  1219. categoryMenu
  1220.         "Private - Answer the category pane menu."
  1221.     ^Menu
  1222.         labels: 'check\remove\rename\add\test' withCrs
  1223.         lines: #(1 4)
  1224.         selectors: #(checkCategories removeCategory renameCategory addCategory
  1225.  xTestx)!
  1226.  
  1227. changeCategory
  1228.         "change the category of the currently displayed
  1229.          method. Display a list of all the defined
  1230.          categories."
  1231.    | categories newCategory |
  1232.     " currentCategory isNil  no method displayed
  1233.         ifTrue: [ Terminal bell. ^nil ]. "
  1234.     categories := self categories asArray.
  1235.     newCategory :=
  1236.         (Menu
  1237.             labelArray: categories
  1238.             lines: Array new
  1239.             selectors: categories)
  1240.                 popUpAt: Cursor position.
  1241.     ( newCategory isNil
  1242.         or: [ newCategory = currentCategory])
  1243.             ifFalse: [
  1244.               displayedMethod isNil
  1245.                 ifFalse: [
  1246.                   self selectedClass
  1247.                      changeCategoryFor: displayedMethod
  1248.                         from: currentCategory
  1249.                         to: newCategory.
  1250.                   currentCategory := newCategory.
  1251.                   self
  1252.                     changed: #selectors;
  1253.                     changed: #editedCategory.
  1254.                  ]
  1255.                ifTrue: [
  1256.                     Menu message:
  1257.                         'sorry, but you have to select method too'.
  1258.                ]
  1259.             ].
  1260.     ^nil!
  1261.  
  1262. checkCategories
  1263.         "Just to be sure. Check stored categories for double entries
  1264.          or selectors without categories.
  1265.          In case of a double entry, keep one and throw away the rest.
  1266.          Very simple. Too simple? Should not happen anyway.
  1267.          In case of no category, create xERRORx category and throw
  1268.          it in there. In this case update the category pane."
  1269.     | errorSet |
  1270.     selectedClass isNil
  1271.         ifTrue: [^self].
  1272.     errorSet := self selectedClass checkCategories.
  1273.     errorSet isEmpty
  1274.         ifFalse: [
  1275.             selectedCategory := #xERRORx.
  1276.             self selectedClass
  1277.                 addCategory: selectedCategory.
  1278.             errorSet do: [ :selector |
  1279.                 self selectedClass
  1280.                     addSelector: selector
  1281.                         category: selectedCategory
  1282.             ].
  1283.             self
  1284.                 changed: #categories
  1285.                     with: #restoreSelected:
  1286.                     with: selectedCategory;
  1287.                 changed: #selectors
  1288.         ].!
  1289.  
  1290. editedCategory
  1291.         "Private - Return the category of the
  1292.          currently displayed method."
  1293.     currentCategory isNil
  1294.         ifTrue: [^Array new].
  1295.     ^( Array with: 'category: ', currentCategory) asSortedCollection!
  1296.  
  1297. initSelectedCategory
  1298.         "private - if there is only one category
  1299.          select it straight away and show its
  1300.          selectors, otherwise set selectedCategory
  1301.          to nil."
  1302.     | dict |
  1303.     dict := self selectedClass allCategories.
  1304.     dict size = 1
  1305.         ifFalse: [ ^selectedCategory := nil ].
  1306.     "a strange way to get the only category"
  1307.     dict keys do: [ :k | selectedCategory := k ].!
  1308.  
  1309. removeCategory
  1310.         "private - Delete selected category. But only if it
  1311.          does not contain any methods."
  1312.     self selectors size = 0
  1313.         ifFalse: [ ^Menu message: 'Remove methods first!!'].
  1314.     self selectedClass removeCategory: selectedCategory.
  1315.     selectedCategory := nil.
  1316.     self changed: #categories!
  1317.  
  1318. renameCategory
  1319.         "Private - Rename selected category."
  1320.     | newName |
  1321.     ( selectedClass isNil or: [ selectedCategory isNil ])
  1322.         ifTrue: [^self].
  1323.     newName := Prompter
  1324.         prompt: ' rename category: ', selectedCategory printString
  1325.         default: selectedCategory printString.
  1326.     ( newName isEmpty  or: [ newName asSymbol = selectedCategory ])
  1327.         ifTrue: [ ^self ].
  1328.     self selectedClass
  1329.             renameCategoryFrom: selectedCategory to: newName asSymbol.
  1330.     selectedCategory := newName asSymbol.
  1331.     self changed: #categories
  1332.             with: #restoreSelected:
  1333.             with: selectedCategory.!
  1334.  
  1335. suppressChange: aSymbol
  1336.         "private - the currentCategory pane got
  1337.          selected. Re-reverse the pane."
  1338.     self changed: #editedCategory! !
  1339.  
  1340.  
  1341. !CategorizedClassBrowser methodsInCategory: 'instanceClass'!
  1342.  
  1343. changeClassInstance: aBoolean
  1344.         "private - if aBoolean is false change to class
  1345.          method display, otherwise change to instance display."
  1346.     aBoolean
  1347.         ifTrue: [
  1348.             self
  1349.                 changed: #classes;
  1350.                 changed: #instances
  1351.                     with: #restoreSelected:
  1352.                     with: 1
  1353.         ]
  1354.         ifFalse: [
  1355.             self
  1356.                 changed: #instances;
  1357.                 changed: #classes
  1358.                     with: #restoreSelected:
  1359.                     with: 1
  1360.         ].
  1361.         instanceSelectedLast := aBoolean!
  1362.  
  1363. class: aSymbol
  1364.         "Private - Change the state of the browser
  1365.          so that class messages are selected."
  1366.     instanceSelectedLast := methodSelectedLast := false.
  1367.     self initSelectedCategory.
  1368.     self
  1369.         changed: #categories
  1370.             with: #restoreSelected:
  1371.             with: selectedCategory;
  1372.         changed: #instances;
  1373.         changed: #selectors;
  1374.         changed: #text.
  1375.     self checkCategories.!
  1376.  
  1377. instance: aSymbol
  1378.         "Private - Change the state of the browser
  1379.          so that instance messages are selected."
  1380.     instanceSelectedLast := true.
  1381.     methodSelectedLast := false.
  1382.     self initSelectedCategory.
  1383.     self
  1384.         changed: #categories
  1385.             with: #restoreSelected:
  1386.             with: selectedCategory;
  1387.         changed: #classes;
  1388.         changed: #selectors;
  1389.         changed: #text.
  1390.     self checkCategories.! !
  1391.  
  1392.  
  1393. !CategorizedClassBrowser methodsInCategory: 'classDoc'!
  1394.  
  1395. docMenu
  1396.         "private - return menu to either edit the class
  1397.          description or display class documentation."
  1398.     ^Menu
  1399.         labels: 'documentation\edit' withCrs
  1400.         lines: Array new
  1401.         selectors: #(openDoc straightTextMenu)!
  1402.  
  1403. openDoc
  1404.         "Open a pane for viewing and editing the
  1405.          class and variable documentation."
  1406.     ClassDocBrowser new openFor: selectedClass! !
  1407.  
  1408.  
  1409. !CategorizedClassBrowser methodsInCategory: 'selectors'!
  1410.  
  1411. newMethod
  1412.         "Private - Display the text for a new
  1413.          method template in the text pane.
  1414.          Ask for category if none is selected"
  1415.     selectedClass isNil
  1416.         ifTrue: [self error: 'no class selected'].
  1417.     selectedCategory isNil
  1418.         ifTrue: [
  1419.             self categories size = 0
  1420.                 ifTrue: [ self addCategory ]
  1421.         ].
  1422.     selectedCategory isNil
  1423.         ifTrue: [ ^Menu message: 'select category first' ].
  1424.     ^super newMethod!
  1425.  
  1426. removeSelector
  1427.         "Private - Remove the selected method."
  1428.     | aString |
  1429.     methodSelectedLast
  1430.         ifFalse: [^nil].
  1431.     selectedMethod isNil
  1432.         ifTrue: [^nil].
  1433.     self selectedClass
  1434.         removeSelector: selectedMethod
  1435.         category: selectedCategory.
  1436.     ^super removeSelector!
  1437.  
  1438. selector: aSymbol
  1439.         "Private - Display the selected
  1440.          method in the text pane."
  1441.     super selector: aSymbol.
  1442.     displayedMethod := aSymbol.
  1443.     self addCurrentToHistory.!
  1444.  
  1445. selectorMenu
  1446.         "Private - Answer the selector pane menu."
  1447.     ^Menu
  1448.         labels: 'remove\new method\senders\implementors\history' withCrs
  1449.         lines: ( Array with: 4 )
  1450.         selectors: #(removeSelector newMethod senders implementors
  1451.  showHistory)!
  1452.  
  1453. selectors
  1454.         "Private - Answer a sorted list of method
  1455.          selectors for the selected class and
  1456.          dictionary type (class or instance)."
  1457.     ( selectedClass isNil or: [ selectedCategory isNil])
  1458.         ifTrue: [^Array new].
  1459.     ^(self selectedClass
  1460.             selectorsForCategory: selectedCategory)
  1461.               asSortedCollection! !
  1462.  
  1463.  
  1464. !CategorizedClassBrowser methodsInCategory: 'window'!
  1465.  
  1466. collapsedLabel
  1467.         "Private - Answer the
  1468.          collapsed label."
  1469.     ^' CCHB '!
  1470.  
  1471. label
  1472.         "Private - Answer the window label."
  1473.     ^'CClass Hierarchy Browser'!
  1474.  
  1475. topMenu
  1476.         "private - return menu for the top pane.
  1477.          For this application return standard one."
  1478.     ^TopDispatcher menu! !
  1479.  
  1480.  
  1481. !Class methodsInCategory: 'etc'!
  1482.  
  1483. fileOutDocOn: aStream
  1484.         "Append the class documentation
  1485.          for the receiver to aStream.
  1486. !!!!!! max"
  1487.     | aString |
  1488.     aStream
  1489.         nextPut: $!!;  "this should force the compiler
  1490.                        to introduce the class, before
  1491.                        we add the documentation."
  1492.         cr; cr;
  1493.         nextPutAll: self printString; space;
  1494.         nextPutAll: 'class comment: '; cr;
  1495.         nextPutAll: self class comment storeString, '.'; cr; cr.
  1496.  
  1497.     self comment keysValuesDo: [ :var :text |
  1498.         aStream
  1499.             nextPutAll: self printString; space;
  1500.             nextPutAll: 'commentFor: ', var storeString, ' put:'; cr;
  1501.             nextPutAll: text storeString;
  1502.             nextPutAll: '.'; cr; cr
  1503.     ]! !
  1504.  
  1505.  
  1506. !Behavior methodsInCategory: 'comment'!
  1507.  
  1508. commentFor: aVariable
  1509.         "return comment for aVariable
  1510. !!!!!! max"
  1511.     comment isNil
  1512.         ifTrue: [
  1513.             ^'not documented'
  1514.         ].
  1515.     ^comment at: aVariable ifAbsent: [ 'not documented' ]!
  1516.  
  1517. commentFor: aVariable put: aString
  1518.         "store comment aString for aVariable
  1519. !!!!!! max"
  1520.     comment isNil
  1521.         ifTrue: [
  1522.             comment := Dictionary new
  1523.         ].
  1524.     ^comment at: aVariable put: aString! !
  1525.  
  1526.  
  1527. !Behavior methodsInCategory: 'etc'!
  1528.  
  1529. addCategory: aCategory
  1530.         "add a new category to the this class.
  1531. !!!!!! max."
  1532.     | categories |
  1533.     categories := self allCategories.
  1534.     categories at: aCategory
  1535.         ifAbsent: [ categories at: aCategory put: Set new ]!
  1536.  
  1537. categoryFor: aSelector
  1538.         "return the category of aSelector.
  1539. !!!!!! max"
  1540.     self allCategories keysValuesDo: [ :aCategory :aSet |
  1541.         ( aSet detect: [ :sample | sample = aSelector ]
  1542.                 ifNone: [ nil ])
  1543.             isNil
  1544.         ifFalse: [ ^aCategory ]
  1545.     ].
  1546.     "can't find a category. Check if selector is still
  1547.         around."
  1548.     self selectors detect: [ :anotherSelector |
  1549.             aSelector == anotherSelector
  1550.         ]
  1551.         ifNone: [ ^nil ]. "has been removed"
  1552.     Menu message: 'check categories in class <', name, '>'.
  1553.     ^#etc! !
  1554.  
  1555.  
  1556. !ProjectClassHBrowser class methodsInCategory: 'initialize'!
  1557.  
  1558. initialize
  1559.         "initialize the class variables.
  1560.          Projects holds a dictionary with a key for
  1561.          each project."
  1562.     Projects := Dictionary new.!
  1563.  
  1564. install
  1565.         "install the project browser in screen menu."
  1566.  
  1567.     ( ReadStream on: '!! ScreenDispatcher methods !!
  1568. openClassBrowser
  1569.         "Private - Open a class hierarchy browser."
  1570.     ProjectClassHBrowser new
  1571.         openOn: (Array with: Object) !! !!')
  1572.     fileIn! !
  1573.  
  1574.  
  1575. !ProjectClassHBrowser class methodsInCategory: 'inquire'!
  1576.  
  1577. projects
  1578.         "return a dictionary containing all
  1579.          projects."
  1580.     ^Projects! !
  1581.  
  1582.  
  1583. !ProjectClassHBrowser class methodsInCategory: 'bugs&info'!
  1584.  
  1585. bugs
  1586.         "return string telling you about the known bugs"
  1587.     ^'
  1588. ProjectClassHBrowser:
  1589. =====================
  1590.  
  1591. 1) There is no way yet to add methods to a project when installing
  1592.     them from a file. Need some class methods like
  1593.         ProjectClassHBrowser project:addMethod:
  1594.     Maybe this should go in a seperate class anyway.
  1595.  
  1596. 2) At the moment you can''t remove a method from a project, except
  1597.     by editing
  1598.         (ProjectClassHBrowser projects at:#project) inspect
  1599.  
  1600. 3) For no particular reason the instance variable holding
  1601.     all the changes is called changeDirectory. Why ..Directory?
  1602.     Because it is a Dictionary. Reason enough?
  1603.  
  1604.  ', super bugs! !
  1605.  
  1606.  
  1607. !ProjectClassHBrowser methodsInCategory: 'selectors'!
  1608.  
  1609. removeSelector
  1610.         "Private - Remove the selected method.
  1611.          Also remove it from the project directory."
  1612.     | tmp |
  1613.     methodSelectedLast
  1614.         ifFalse: [^nil].
  1615.     selectedMethod isNil
  1616.         ifTrue: [^nil].
  1617.     tmp := self classChangeDirectory.
  1618.     ( instanceSelectedLast
  1619.         ifTrue: [ tmp at: 1 ]
  1620.         ifFalse: [ tmp at: 2 ] )
  1621.             remove: selectedMethod ifAbsent:[].
  1622.     ^super removeSelector!
  1623.  
  1624. selectorMenu
  1625.         "Private - Answer the selector pane menu."
  1626.     ^Menu
  1627.         labels: 'remove\new method\senders\implementors\add to project\history'
  1628.  withCrs
  1629.         lines: ( Array with: 4 )
  1630.         selectors: #(removeSelector newMethod senders implementors
  1631.  addCurrentToProject showHistory)! !
  1632.  
  1633.  
  1634. !ProjectClassHBrowser methodsInCategory: 'initialize'!
  1635.  
  1636. openOn: aCollection
  1637.         "Create a class hierarchy browser window giving access
  1638.          to the classes in aCollection and their subclasses.
  1639.          There is a project name associated with this window.
  1640.          Therefore we also keep a diary of all the methods
  1641.          changed while working on this project. Later we
  1642.          can ask to file out all the changed methods."
  1643.     | newName |
  1644.     Projects isNil ifTrue: [  ProjectClassHBrowser initialize ].
  1645.     newName := self askForProjectName.
  1646.     newName isNil ifTrue: [ ^nil ].
  1647.     changeDirectory :=
  1648.         ( Projects at: newName
  1649.                    ifAbsent: [ Projects at: newName
  1650.                                     put: Dictionary new
  1651.                              ]).
  1652.     projectName := newName.
  1653.     ^super openOn: aCollection! !
  1654.  
  1655.  
  1656. !ProjectClassHBrowser methodsInCategory: 'project'!
  1657.  
  1658. addCurrentToProject
  1659.         "private - add current selected method to
  1660.          project log."
  1661.     self addMethodToProject: selectedMethod!
  1662.  
  1663. addMethodToProject: aMethod
  1664.         "private - add aMethod to the project log."
  1665.     | tmp |
  1666.     tmp := self classChangeDirectory.
  1667.     instanceSelectedLast
  1668.         ifTrue: [( tmp at: 1) add: aMethod ]
  1669.         ifFalse: [( tmp at: 2) add: aMethod ]!
  1670.  
  1671. askForProjectName
  1672.         "private - ask user for new project name.
  1673.          Set variable projectName accordingly.
  1674.          First display a menu with all known
  1675.          projects. For new projects click the last
  1676.          menu line which will open a prompter to
  1677.          input the proper name. Return the new selected
  1678.          project name or nil if none was selected."
  1679.     | names index newName |
  1680.     names := Projects keys asOrderedCollection.
  1681.     names size = 0
  1682.         ifTrue: [ index := 0 ]
  1683.         ifFalse: [
  1684.             names addLast: '>> New Project?'.
  1685.             names := names asArray.
  1686.             index := ( Menu
  1687.                         labelArray: names
  1688.                         lines: Array new
  1689.                         selectors: ( 1 to: names size))
  1690.                      popUpAt: Cursor offset.
  1691.             index isNil ifTrue: [ ^nil ]
  1692.         ].
  1693.     index = names size
  1694.         ifTrue: [ "get new name"
  1695.             newName := Prompter
  1696.                             prompt: ' Project name?'
  1697.                             default: ''.
  1698.             newName isEmpty ifTrue: [ ^nil ].
  1699.         ]
  1700.         ifFalse: [
  1701.             newName := names at: index
  1702.         ].
  1703.     ^newName!
  1704.  
  1705. changeProjectName
  1706.         "private - ask user for a different name
  1707.          for the current project.
  1708.          update label.
  1709. !!!!!! Don't know how to update collapsed label"
  1710.     | newName |
  1711.     ( newName := self typeNewProjectName) isNil
  1712.         ifTrue: [ ^nil ].
  1713.     ( Projects at: newName ifAbsent: [ nil ]) isNil
  1714.         ifFalse: [
  1715.             ^Menu message: '<', newName,
  1716.                     '> is used for a different project'
  1717.         ].
  1718.     Projects at: newName
  1719.         put: ( Projects at: projectName).
  1720.     Projects removeKey: projectName.
  1721.     projectName := newName.
  1722.     self changed: #label!
  1723.  
  1724. classChangeDirectory
  1725.         "private - return an array for the selected class
  1726.          for adding new methods to change log. This array is
  1727.          stored in class variable Projects.
  1728.  
  1729.          The changeDirectory is the value of the dictionary
  1730.          entry for this project in the class variable Class.
  1731.          It is a dictionary with a key for each class changes
  1732.          have been made. For each class a array of 2 sets
  1733.          is kept, for instance methods and class methods
  1734.          respectively.
  1735.          We also set a flag if the class specifications
  1736.          were changed."
  1737.     changeDirectory at: selectedClass
  1738.         ifAbsent: [
  1739.             changeDirectory at: selectedClass
  1740.                     put: ( Array with: Set new with: Set new with: false) ].
  1741.     ^changeDirectory at: selectedClass!
  1742.  
  1743. fileOutProject
  1744.         "private - file out all the methods and
  1745.          class definitions changed or created while
  1746.          developing of this project."
  1747.     | aFileStream |
  1748.     changeDirectory isNil
  1749.         ifTrue: [^self].
  1750.     CursorManager execute change.
  1751.     aFileStream := Disk newFile:
  1752.         (File
  1753.             fileName: projectName
  1754.             extension: (String with: $c with: $l with: $s)).
  1755.     aFileStream lineDelimiter: 10 asCharacter.
  1756.     self fileOutProjectHeaderOn: aFileStream.
  1757.     "first file out all the headers of all newly created
  1758.      classes to avoid references to a class before the
  1759.      new image knows about them."
  1760.     changeDirectory keysValuesDo: [ :aClass :changeArray |
  1761.         ( changeArray at: 3)   "class was newly created"
  1762.             ifTrue: [
  1763.                 aClass fileOutOn: aFileStream.
  1764.                 aClass fileOutDocOn: aFileStream.
  1765.                 aFileStream nextChunkPut: String new.
  1766.              ]
  1767.     ].
  1768.     changeDirectory keysValuesDo: [ :aClass :changeArray |
  1769.         ( changeArray at: 2) size == 0  "file out class definitions"
  1770.             ifFalse: [
  1771.                 ( CategoryClassReader forClass: aClass class)
  1772.                     fileOutOnWithCategories: aFileStream
  1773.                     selection: ( changeArray at: 2).
  1774.              ].
  1775.         ( changeArray at: 1) size == 0  "file out methods"
  1776.             ifFalse: [
  1777.                 ( CategoryClassReader forClass: aClass )
  1778.                     fileOutOnWithCategories: aFileStream
  1779.                     selection: ( changeArray at: 1).
  1780.              ].
  1781.     ].
  1782.     aFileStream close.
  1783.     CursorManager normal change!
  1784.  
  1785. fileOutProjectHeaderOn: aFileStream
  1786.         "private - write some information on the
  1787.          current project at the beginning of the
  1788.          file."
  1789.     aFileStream
  1790.         nextPutAll: '"****************************'; cr;
  1791.         nextPutAll: ' *   ', ( Date dateAndTimeNow at: 1) printString, '  ',
  1792.                 ( Date dateAndTimeNow at: 2) printString; cr;
  1793.         nextPutAll: ' *'; cr;
  1794.         nextPutAll: ' *   Project: ', projectName; cr;
  1795.         nextPutAll: ' *'; cr; cr;
  1796.         nextPutAll: '    (Disk file: ''',
  1797.             (File fileName: projectName extension: 'cls'),
  1798.             ''') fileIn; close.'; cr;
  1799.         nextPutAll: '"'; nextPut: $!!; cr.!
  1800.  
  1801. topMenu
  1802.     | selection |
  1803.     ^Menu
  1804.         labels: 'change name\file out' withCrs
  1805.         lines: #()
  1806.         selectors: #(changeProjectName fileOutProject)!
  1807.  
  1808. typeNewProjectName
  1809.         "private - ask user with a prompter for
  1810.          a new project name and return this name."
  1811.     | newName |
  1812.     newName := Prompter
  1813.                     prompt: ' Project name?'
  1814.                     default: ''.
  1815.     newName isEmpty ifTrue: [ ^nil ].
  1816.     ^newName! !
  1817.  
  1818.  
  1819. !ProjectClassHBrowser methodsInCategory: 'text'!
  1820.  
  1821. successfulCompiledMethod: aMethod
  1822.         "private - aMethod has been sucessfully compiled.
  1823.          Isn't that great. Have a beer.
  1824.          Also add it to the project log."
  1825.     self addMethodToProject: aMethod! !
  1826.  
  1827.  
  1828. !ProjectClassHBrowser methodsInCategory: 'classes'!
  1829.  
  1830. acceptClass: aString from: aDispatcher
  1831.         "Private - Accept aString as an updated
  1832.          class specification and compile it.  Notify
  1833.          aDispatcher if the compiler detects errors."
  1834.     | result |
  1835.     result := Compiler
  1836.         evaluate: aString
  1837.         in: nil class
  1838.         to: nil
  1839.         notifying: aDispatcher
  1840.         ifFail: [^false].
  1841.     Smalltalk logEvaluate: aString.
  1842.     self classSpecificationsHaveChanged.
  1843.     ^(result isKindOf: Class)!
  1844.  
  1845. classSpecificationsHaveChanged
  1846.         "private - mark in project log that
  1847.          the specifications for the currently
  1848.          selected class have changed."
  1849.     self classChangeDirectory at: 3 put: true! !
  1850.  
  1851.  
  1852. !ProjectClassHBrowser methodsInCategory: 'window'!
  1853.  
  1854. collapsedLabel
  1855.         "Private - Answer the
  1856.          collapsed label."
  1857.     ^'<', projectName, '>'!
  1858.  
  1859. label
  1860.         "Private - Answer the window label."
  1861.     ^'Project: <', projectName, '>'! !
  1862.  
  1863.  
  1864. !CategoryClassReader methodsInCategory: 'inOut'!
  1865.  
  1866. instanceHeaderOn: aStream  category: aCategory
  1867.         "Private - Write a header to aStream which identifies
  1868.          the class described by the receiver.  The header
  1869.          precedes the source code for the methods.
  1870.          Add category too."
  1871.     aStream
  1872.         cr;
  1873.         nextPut: $!!;
  1874.         nextPutAll: class name;
  1875.         space;
  1876.         nextPutAll: 'methodsInCategory: ';
  1877.         nextPutAll: aCategory asString printString;
  1878.         nextPut: $!!!
  1879.  
  1880. sortIntoCategories: aSet
  1881.         "private - put all the methods in aSet into
  1882.          a dictionary where the key is the category
  1883.          and the value is a set containing all the methods
  1884.          belonging to the same category."
  1885.     | dictionary category |
  1886.     dictionary := Dictionary new.
  1887.     aSet do: [ :aSelector |
  1888.         ( category := class categoryFor: aSelector) isNil
  1889.             ifFalse: [ "ok found a category for it"
  1890.                 dictionary at: category
  1891.                     ifAbsent: [ dictionary at: category put: Set new ].
  1892.                 ( dictionary at: category) add: aSelector.
  1893.             ]
  1894.     ].
  1895.     ^dictionary! !
  1896.  
  1897.  
  1898. !ClassDocBrowser methodsInCategory: 'initialize'!
  1899.  
  1900. docTextInit
  1901.         "private - show the class docu immediatly"
  1902.     | comment |
  1903.     variable := 'CLASS'.
  1904.     self changed: #variables
  1905.             with: #selection: with: 1.
  1906.     (comment := class class comment) isNil
  1907.         ifTrue: [ ^'not documented' ]
  1908.         ifFalse: [ ^comment ]!
  1909.  
  1910. initWindowSize
  1911.         "Answer the initial window extent."
  1912.     ^Display width * 4 // 5 @
  1913.         (Display height // 2)!
  1914.  
  1915. openFor: aClass
  1916.         "Open a pane for viewing and editing the
  1917.          class and variable documentation."
  1918.     | aTopPane |
  1919.     class := aClass.
  1920.     aTopPane := TopPane new
  1921.         model: self;
  1922.         label: 'doc: ', class name;
  1923.         minimumSize: SysFontWidth * 20
  1924.             @ (SysFontHeight * 8);
  1925.         yourself.
  1926.     aTopPane addSubpane:
  1927.         (ListPane new
  1928.             model: self;
  1929.             name: #variables;
  1930.             change: #variable:;
  1931.             "
  1932.             menu: #selectorMenu;
  1933.             "
  1934.             framingRatio: (0@0 extent: 1/5@1)).
  1935.     aTopPane addSubpane:
  1936.         (TextPane new
  1937.             model: self;
  1938.             name: #docText;
  1939.             change: #docChange:from:;
  1940.             framingRatio: (1/5@0 extent: 4/5@1)).
  1941.     aTopPane dispatcher open scheduleWindow!
  1942.  
  1943. variables
  1944.         "private - return an array with all the instance
  1945.          and class variables."
  1946.     | list |
  1947.     list := OrderedCollection new.
  1948.     list addLast: 'CLASS'.
  1949.     class instanceVariableString asArrayOfSubstrings do: [ :l |
  1950.         list addLast: l
  1951.     ].
  1952.     class classVariableString asArrayOfSubstrings do: [ :l |
  1953.         list addLast: l
  1954.     ].
  1955.     ^list asArray! !
  1956.  
  1957.  
  1958. !ClassDocBrowser methodsInCategory: 'work'!
  1959.  
  1960. docChange: aString from: aDispatcher
  1961.         "private - accept a new docu string. Store it
  1962.          in Behavior. CLASS docu in class class comment,
  1963.          variables in class comment as dictionary."
  1964.     | dict |
  1965.     variable = 'CLASS'
  1966.         ifTrue: [ "get class docu"
  1967.             class class comment: aString
  1968.         ]
  1969.         ifFalse: [ "write variable docu"
  1970.             class commentFor: variable  put: aString
  1971.         ].
  1972.     ^true!
  1973.  
  1974. docText
  1975.         "return comment for selected variable."
  1976.     | comment dict |
  1977.     variable isNil
  1978.         ifTrue: [ ^self docTextInit ].
  1979.     variable = 'CLASS'
  1980.         ifTrue: [ "get class docu"
  1981.             (comment := class class comment) isNil
  1982.                 ifTrue: [ ^'not documented' ]
  1983.                 ifFalse: [ ^comment ]
  1984.         ]
  1985.         ifFalse: [ "get variable docu"
  1986.             ^class commentFor: variable
  1987.         ].
  1988.     ^'strange ERROR'!
  1989.  
  1990. variable: aString
  1991.         "private - a new variable got selected; display
  1992.         its documentation."
  1993.     variable := aString.
  1994.     self changed: #docText.! !
  1995.  
  1996.  
  1997.